home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / pcl-env-internal.lsp < prev    next >
Text File  |  1992-07-09  |  9KB  |  262 lines
  1. (DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
  2. (il:filecreated "28-Aug-87 18:42:36" il:{phylum}<pcl>pcl-env-internal.\;1 8356   
  3.  
  4.       il:|changes| il:|to:|  (il:vars il:pcl-env-internalcoms)
  5.                              (il:props (il:pcl-env-internal il:makefile-environment))
  6.                              (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
  7.                                     stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
  8.                                     stack-frame-name compiled-closure-fnheader compiled-closure-env)
  9. )
  10.  
  11.  
  12. ; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
  13.  
  14. (il:prettycomprint il:pcl-env-internalcoms)
  15.  
  16. (il:rpaqq il:pcl-env-internalcoms (
  17.  
  18. (il:* il:|;;;| "***************************************")
  19.  
  20.                                    
  21.  
  22. (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
  23.  
  24.                                    
  25.  
  26. (il:* il:|;;;| "")
  27.  
  28.                                    
  29.  
  30. (il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
  31.  
  32.                                    
  33.  
  34. (il:* il:|;;;| " ")
  35.  
  36.                                    
  37.  
  38. (il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
  39.  
  40.                                    
  41.  
  42. (il:* il:|;;;| " ")
  43.  
  44.                                    
  45.  
  46. (il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
  47.  
  48.                                    
  49.  
  50. (il:* il:|;;;| "   CommonLoops Coordinator")
  51.  
  52.                                    
  53.  
  54. (il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
  55.  
  56.                                    
  57.  
  58. (il:* il:|;;;| "   2400 Hanover St.")
  59.  
  60.                                    
  61.  
  62. (il:* il:|;;;| "   Palo Alto, CA 94303")
  63.  
  64.                                    
  65.  
  66. (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
  67.  
  68.                                    
  69.  
  70. (il:* il:|;;;| "")
  71.  
  72.                                    
  73.  
  74. (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
  75.  
  76.                                    
  77.  
  78. (il:* il:|;;;| " *************************************************************************")
  79.  
  80.                                    
  81.  
  82. (il:* il:|;;;| "")
  83.  
  84.                                    (il:declare\: il:dontcopy (il:prop il:makefile-environment 
  85.                                                                     il:pcl-env-internal))
  86.                                                              (il:* il:\; 
  87.                                                              "We're off to hack the system...")
  88.  
  89.                                    (il:declare\: il:eval@compile il:dontcopy (il:files pcl::abc)
  90.                                           
  91.           
  92.           (il:* il:|;;| "The Deltas and The East and The Freeze")
  93. )
  94.                                    (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
  95.                                           stack-frame-fn-header stack-frame-pc 
  96.                                           fnheader-debugging-info stack-frame-name 
  97.                                           compiled-closure-fnheader compiled-closure-env)))
  98.  
  99.  
  100.  
  101. (il:* il:|;;;| "***************************************")
  102.  
  103.  
  104.  
  105.  
  106. (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
  107.  
  108.  
  109.  
  110.  
  111. (il:* il:|;;;| "")
  112.  
  113.  
  114.  
  115.  
  116. (il:* il:|;;;| 
  117. "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws."
  118. )
  119.  
  120.  
  121.  
  122.  
  123. (il:* il:|;;;| " ")
  124.  
  125.  
  126.  
  127.  
  128. (il:* il:|;;;| 
  129. "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
  130. )
  131.  
  132.  
  133.  
  134.  
  135. (il:* il:|;;;| " ")
  136.  
  137.  
  138.  
  139.  
  140. (il:* il:|;;;| 
  141. "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
  142. )
  143.  
  144.  
  145.  
  146.  
  147. (il:* il:|;;;| "   CommonLoops Coordinator")
  148.  
  149.  
  150.  
  151.  
  152. (il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
  153.  
  154.  
  155.  
  156.  
  157. (il:* il:|;;;| "   2400 Hanover St.")
  158.  
  159.  
  160.  
  161.  
  162. (il:* il:|;;;| "   Palo Alto, CA 94303")
  163.  
  164.  
  165.  
  166.  
  167. (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
  168.  
  169.  
  170.  
  171.  
  172. (il:* il:|;;;| "")
  173.  
  174.  
  175.  
  176.  
  177. (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
  178.  
  179.  
  180.  
  181.  
  182. (il:* il:|;;;| " *************************************************************************")
  183.  
  184.  
  185.  
  186.  
  187. (il:* il:|;;;| "")
  188.  
  189. (il:declare\: il:dontcopy 
  190.  
  191. (il:putprops il:pcl-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
  192. )
  193.  
  194.  
  195.  
  196. (il:* il:\; "We're off to hack the system...")
  197.  
  198. (il:declare\: il:eval@compile il:dontcopy 
  199. (il:filesload pcl::abc)
  200. )
  201.  
  202. (defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
  203.                                                                    (il:stackp y)
  204.                                                                    (eql (il:fetch (il:stackp il:edfxp
  205.                                                                                          )
  206.                                                                            il:of x)
  207.                                                                         (il:fetch (il:stackp il:edfxp
  208.                                                                                          )
  209.                                                                            il:of y))))
  210.  
  211.  
  212. (defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
  213.  
  214.  
  215. (defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
  216.  
  217.  
  218. (defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
  219.  
  220.  
  221. (defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
  222.  
  223.  
  224. (defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
  225.                                                               il:of fnheader))
  226.                                                  (name-table-words
  227.                                                   (let ((size (il:fetch (il:fnheader il:ntsize)
  228.                                                                  il:of fnheader)))
  229.                                                        (if (zerop size)
  230.                                                            il:wordsperquad
  231.                                                            (* size 2))))
  232.                                                  (past-name-table-in-words (+ (il:fetch (il:fnheader
  233.                                                                                          
  234.                                                                                      il:overheadwords
  235.                                                                                          )
  236.                                                                                  il:of fnheader)
  237.                                                                               name-table-words)))
  238.                                                 (and (= (- start-pc (* il:bytesperword 
  239.                                                                        past-name-table-in-words))
  240.                                                         il:bytespercell)
  241.           
  242.           (il:* il:|;;| "It's got a debugging-info list.")
  243.  
  244.                                                      (il:\\getbaseptr fnheader 
  245.                                                             past-name-table-in-words))))
  246.  
  247.  
  248. (defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| f